home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / games / litpz2gf.zoo / blckpuz1.lst next >
File List  |  1992-07-16  |  9KB  |  470 lines
  1. ' blckpuz1.gfa
  2. ' Block puzzle number 1 written in GFA Basic 3.5
  3. ' Seymour Shlien   14-July-1991
  4. ' 624 Courtenay Avenue
  5. ' Ottawa, Ontario
  6. ' Canada, K2A 3B5
  7. ' Public domain software
  8. '
  9. ' Solution 1 to B
  10. ' Move pieces in following order
  11. ' 5,4,1,2,3,4 (up and right),1,6,7,8,9,5,4,1,6
  12. ' 7 (halfway),9,5,4,8,6,2,3,1.
  13. '
  14. ' Solution 1 to C
  15. ' 5,4,1,2,3,4 (up and right) 1,6,7,8,9,5
  16. ' 4,1,6,7,8,9,5 (left and up),9,8,5,4,1
  17. ' 3,2,7,6,4 (up and left) 6
  18. ' 7,4,5,6,7,5 (right,up).
  19. ' 3,2,5,4,3,2 4(down and right),2,3,6,7,1
  20. ' 4,5,2,3,6,7,1,4(left,up),9,8,1
  21. '
  22. '
  23. ' Reference: Martin Gardner's "Sixth Book of Mathematical Games
  24. ' from Scientific American" W.H. Freeman and Company, San Francisco
  25. ' page 65
  26. '
  27. DIM block_x%(10),block_y%(10),block_w%(10),block_h%(10)
  28. DIM board%(4,5)
  29. DIM edge_status!(4)
  30. DIM arrow_translation%(4)
  31. DIM xbs_files$(30)
  32. rez%=XBIOS(4)
  33. IF rez%<>0
  34.   ALERT 3," Please switch   to | low  resolution! ",1,"Oops",b%
  35.   STOP
  36. ENDIF
  37. DEFMOUSE 0
  38. DIM deskcolors%(16)
  39. @get_deskcolors
  40. x_scale%=20
  41. y_scale%=20
  42. board_w%=4
  43. board_h%=5
  44. @load_block_descriptor
  45. @load_board
  46. @load_mouse_poly
  47. @dir_xbs_files
  48. @read_sound
  49. @dosound
  50. VSETCOLOR 0,12,12,10
  51. VSETCOLOR 3,10,14,0
  52. VSETCOLOR 5,14,14,12
  53. DEFFILL 0
  54. PBOX 0,0,319,199
  55. DEFFILL 1,1
  56. @draw_entire_puzzle
  57. LOCATE 19,3
  58. PRINT "Hit space bar"
  59. LOCATE 19,4
  60. PRINT "to quit"
  61. arrow_translation%(1)=4
  62. arrow_translation%(2)=3
  63. arrow_translation%(3)=1
  64. arrow_translation%(4)=2
  65. last_motion%=-1
  66. FOR i%=1 TO 1000
  67.   block%=@pick_block
  68.   IF block%>0
  69.     motion%=@compute_edge_status(block%)
  70.     IF motion%>0
  71.       @execute_shift(block%,motion%)
  72.       last_motion%=motion%
  73.     ENDIF
  74.   ENDIF
  75.   '  @print_board
  76.   PAUSE 20
  77. NEXT i%
  78. > PROCEDURE get_deskcolors
  79.   LOCAL i%
  80.   FOR i%=0 TO 15
  81.     deskcolors%(i%)=XBIOS(7,i%,-1)
  82.   NEXT i%
  83. RETURN
  84. > PROCEDURE restore_deskcolors
  85.   LOCAL i%
  86.   FOR i%=0 TO 15
  87.     SETCOLOR i%,deskcolors%(i%)
  88.   NEXT i%
  89. RETURN
  90. > PROCEDURE draw_block(number%)
  91.   LOCAL x%,y%
  92.   DEFFILL 3
  93.   x%=20+block_x%(number%)*x_scale%
  94.   y%=20+block_y%(number%)*y_scale%
  95.   PBOX x%,y%,x%+block_w%(number%)*x_scale%-3,y%+block_h%(number%)*y_scale%-3
  96.   GRAPHMODE 2
  97.   TEXT x%+2,y%+7,STR$(number%)
  98.   GRAPHMODE 1
  99. RETURN
  100. > PROCEDURE draw_entire_puzzle
  101.   LOCAL i%
  102.   DEFFILL 1
  103.   PBOX 19,19,21+board_w%*x_scale%,21+board_h%*y_scale%
  104.   FOR i%=1 TO numblk%
  105.     @draw_block(i%)
  106.   NEXT i%
  107.   TEXT 12,15,"A"
  108.   TEXT 20+board_w%*x_scale%,15,"B"
  109.   TEXT 12,30+board_h%*y_scale%,"C"
  110.   TEXT 20+board_w%*x_scale%,30+board_h%*y_scale%,"D"
  111.   '
  112.   TEXT 140,60,"Can you move block 1"
  113.   TEXT 140,70,"to corner B (easy) or"
  114.   TEXT 140,80,"corner C or D (harder)"
  115. RETURN
  116. > FUNCTION pick_block
  117. LOCAL i%,j%
  118. REPEAT
  119.   IF INKEY$<>""
  120.     @restore_deskcolors
  121.     END
  122.   ENDIF
  123. UNTIL MOUSEK<>0
  124. i%=(MOUSEX-20) DIV x_scale%
  125. j%=(MOUSEY-20) DIV y_scale%
  126. INC i%
  127. INC j%
  128. IF i%>=1 AND i%<=board_w%
  129.   IF j%>=1 AND j%<=board_h%
  130.     RETURN board%(i%,j%)
  131.   ENDIF
  132. ENDIF
  133. RETURN -1
  134. ENDFUNC
  135. > FUNCTION check_left_edge(n%)
  136. ' determines whether block n% can move left
  137. LOCAL i%,x%,y%
  138. x%=block_x%(n%)
  139. y%=block_y%(n%)
  140. IF x%<1
  141. RETURN FALSE
  142. ENDIF
  143. FOR i%=1 TO block_h%(n%)
  144. IF board%(x%,y%+i%)<>0
  145.   RETURN FALSE
  146. ENDIF
  147. NEXT i%
  148. RETURN TRUE
  149. ENDFUNC
  150. > FUNCTION check_right_edge(n%)
  151. LOCAL i%,x%,y%
  152. x%=block_x%(n%)+block_w%(n%)+1
  153. y%=block_y%(n%)
  154. IF x%>board_w%
  155. RETURN FALSE
  156. ENDIF
  157. FOR i%=1 TO block_h%(n%)
  158. IF board%(x%,y%+i%)<>0
  159. RETURN FALSE
  160. ENDIF
  161. NEXT i%
  162. RETURN TRUE
  163. ENDFUNC
  164. > FUNCTION check_top_edge(n%)
  165. LOCAL x%,y%,i%
  166. x%=block_x%(n%)
  167. y%=block_y%(n%)
  168. IF y%<1
  169. RETURN FALSE
  170. ENDIF
  171. FOR i%=1 TO block_w%(n%)
  172. IF board%(x%+i%,y%)<>0
  173. RETURN FALSE
  174. ENDIF
  175. NEXT i%
  176. RETURN TRUE
  177. ENDFUNC
  178. > FUNCTION check_bottom_edge(n%)
  179. LOCAL x%,y%,i%
  180. x%=block_x%(n%)
  181. y%=block_y%(n%)+block_h%(n%)+1
  182. IF y%>board_h%
  183. RETURN FALSE
  184. ENDIF
  185. FOR i%=1 TO block_w%(n%)
  186. IF board%(x%+i%,y%)<>0
  187. RETURN FALSE
  188. ENDIF
  189. NEXT i%
  190. RETURN TRUE
  191. ENDFUNC
  192. > FUNCTION compute_edge_status(n%)
  193. ' The complicated part of this function is occurs when the
  194. ' block can move in either of two directions. The function
  195. ' then requests another mouse click indicating which direction.
  196. LOCAL i%,sum%,sum2%
  197. edge_status!(1)=@check_left_edge(n%)
  198. edge_status!(2)=@check_right_edge(n%)
  199. edge_status!(3)=@check_top_edge(n%)
  200. edge_status!(4)=@check_bottom_edge(n%)
  201. ' verify unique direction
  202. sum%=0
  203. FOR i%=1 TO 4
  204. IF edge_status!(i%)=TRUE
  205. INC sum%
  206. ENDIF
  207. NEXT i%
  208. rightmouse%=0
  209. ' only one direction to go
  210. IF sum%=1
  211. FOR i%=1 TO 4
  212. IF edge_status!(i%)=TRUE
  213. RETURN i%
  214. ENDIF
  215. NEXT i%
  216. ' two possible directions to go
  217. ELSE IF sum%=2
  218. PAUSE 20
  219. DEFFILL 0
  220. PBOX 130,50,319,120
  221. DEFFILL 5
  222. POLYFILL 6,mawse_x%(),mawse_y%() OFFSET 150,50
  223. COLOR 1
  224. POLYLINE 6,mawse_x%(),mawse_y%() OFFSET 150,50
  225. COLOR 0
  226. LINE 170,50,170,65
  227. LINE 150,65,190,65
  228. sum%=0
  229. GRAPHMODE 2
  230. ' make rightmouse button to negate last move if possible
  231. FOR i%=1 TO 4
  232. IF edge_status!(i%)=TRUE
  233. IF i%=1 AND last_motion%=2
  234. rightmouse%=i%
  235. ELSE IF i%=1
  236. leftmouse%=i%
  237. ENDIF
  238. IF i%=2 AND last_motion%=1
  239. rightmouse%=i%
  240. ELSE IF i%=2
  241. leftmouse%=i%
  242. ENDIF
  243. IF i%=3 AND last_motion%=4
  244. rightmouse%=i%
  245. ELSE IF i%=3
  246. leftmouse%=i%
  247. ENDIF
  248. IF i%=4 AND last_motion%=3
  249. rightmouse%=i%
  250. ELSE IF i%=4
  251. leftmouse%=i%
  252. ENDIF
  253. ENDIF
  254. NEXT i%
  255. ' in some cases no motion is opposite to last_motion%
  256. IF rightmouse%=0
  257. FOR i%=1 TO 4
  258. IF edge_status!(i%)=TRUE
  259. INC sum%
  260. IF sum%=1
  261. TEXT 157,60,CHR$(arrow_translation%(i%))
  262. ENDIF
  263. IF sum%=2
  264. TEXT 177,60,CHR$(arrow_translation%(i%))
  265. ENDIF
  266. ENDIF
  267. NEXT i%
  268. ' rightmouse is set to opposite of last_motion%
  269. ELSE
  270. TEXT 157,60,CHR$(arrow_translation%(leftmouse%))
  271. TEXT 177,60,CHR$(arrow_translation%(rightmouse%))
  272. ENDIF
  273. GRAPHMODE 1
  274. TEXT 200,70,"Click left or"
  275. TEXT 200,80,"right button"
  276. ' get next mouse click
  277. REPEAT
  278. UNTIL MOUSEK<>0
  279. DEFFILL 0
  280. PBOX 130,50,319,120
  281. ' for right mouse click return rightmouse% if defined
  282. IF MOUSEK=2
  283. IF rightmouse%=0
  284. ' search for second direction
  285. sum%=0
  286. FOR i%=1 TO 4
  287. IF edge_status!(i%)=TRUE
  288. INC sum%
  289. ENDIF
  290. IF sum%=2
  291. RETURN i%
  292. ENDIF
  293. NEXT i%
  294. ELSE
  295. RETURN rightmouse%
  296. ENDIF
  297. ENDIF
  298. IF rightmouse%=0
  299. FOR i%=1 TO 4
  300. IF edge_status!(i%)=TRUE
  301. RETURN i%
  302. ENDIF
  303. NEXT i%
  304. ELSE
  305. RETURN leftmouse%
  306. ENDIF
  307. ENDIF
  308. RETURN 0
  309. ENDFUNC
  310. > PROCEDURE update_board(n%,val%)
  311. ' sets the area occupied by block n% in board(*,*)
  312. ' to the value val%
  313. LOCAL i%,j%,x%,y%
  314. FOR j%=1 TO block_h%(n%)
  315. y%=block_y%(n%)+j%
  316. FOR i%=1 TO block_w%(n%)
  317. x%=block_x%(n%)+i%
  318. board%(x%,y%)=val%
  319. NEXT i%
  320. NEXT j%
  321. RETURN
  322. > PROCEDURE move_block(n%,dir%)
  323. ' dir% = 1,2,3,4 for left,right,up,down
  324. SELECT dir%
  325. CASE 1
  326. DEC block_x%(n%)
  327. CASE 2
  328. INC block_x%(n%)
  329. CASE 3
  330. DEC block_y%(n%)
  331. CASE 4
  332. INC block_y%(n%)
  333. ENDSELECT
  334. ' playtune if done
  335. IF n%=1
  336. IF block_x%(1)=2 AND block_y%(1)=0
  337. @dosound
  338. ELSE IF block_x%(1)=2 AND block_y%(1)=3
  339. @dosound
  340. ELSE IF block_x%(1)=0 AND block_y%(1)=3
  341. @dosound
  342. ENDIF
  343. ENDIF
  344. RETURN
  345. > PROCEDURE execute_shift(n%,dir%)
  346. update_board(n%,val%)
  347. gradual_shift(n%,dir%)
  348. move_block(n%,dir%)
  349. update_board(n%,n%)
  350. RETURN
  351. > PROCEDURE gradual_shift(number%,dir%)
  352. LOCAL x%,y%,i%,dist%,xl%,yl%
  353. x%=20+block_x%(number%)*x_scale%
  354. y%=20+block_y%(number%)*y_scale%
  355. GET x%,y%,x%+block_w%(number%)*x_scale%-3,y%+block_h%(number%)*y_scale%-3,sec$
  356. IF dir%>2
  357. dist%=y_scale%
  358. ELSE
  359. dist%=x_scale%
  360. ENDIF
  361. COLOR 1
  362. FOR i%=1 TO dist%
  363. DEFFILL 3,1
  364. VSYNC
  365. SELECT dir%
  366. CASE 1
  367. xl%=x%+block_w%(number%)*x_scale%-3
  368. LINE xl%,y%,xl%,y%+block_h%(number%)*y_scale%-3
  369. DEC x%
  370. PUT x%,y%,sec$
  371. CASE 2
  372. xl%=x%
  373. LINE xl%,y%,xl%,y%+block_h%(number%)*y_scale%-3
  374. INC x%
  375. PUT x%,y%,sec$
  376. CASE 3
  377. yl%=y%+block_h%(number%)*y_scale%-3
  378. LINE x%,yl%,x%+block_w%(number%)*x_scale%-3,yl%
  379. DEC y%
  380. PUT x%,y%,sec$
  381. CASE 4
  382. yl%=y%
  383. LINE x%,yl%,x%+block_w%(number%)*x_scale%-3,yl%
  384. INC y%
  385. PUT x%,y%,sec$
  386. ENDSELECT
  387. NEXT i%
  388. RETURN
  389. > PROCEDURE print_board
  390. LOCAL i%,j%
  391. LOCATE 1,18
  392. FOR j%=1 TO board_h%
  393. FOR i%=1 TO board_w%
  394. PRINT board%(i%,j%);" ";
  395. NEXT i%
  396. PRINT
  397. NEXT j%
  398. RETURN
  399. > PROCEDURE dir_xbs_files
  400. number_of_xbs_files%=0
  401. ~FSETDTA(BASEPAGE+128)
  402. e%=FSFIRST("\XBS\*.XBS",-1)
  403. DO UNTIL e%
  404. xbs_files$(number_of_xbs_files%)=CHAR{BASEPAGE+158}
  405. e%=FSNEXT()
  406. INC number_of_xbs_files%
  407. LOOP
  408. RETURN
  409. > PRO